home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / MENU_UTL / DESIGN / DSORT.PAS < prev    next >
Pascal/Delphi Source File  |  1988-12-27  |  17KB  |  496 lines
  1. (****************************************************************)
  2. (*                     DATABASE TOOLBOX 4.0                     *)
  3. (*     Copyright (c) 1984, 87 by Borland International, Inc.    *)
  4. (*                                                              *)
  5. (*                  TURBO LONG SORT UNIT                        *)
  6. (*                                                              *)
  7. (*  Purpose: Toolbox of routines to implement a general         *)
  8. (*           purpose QuickSort for over 2 billion items.        *)
  9. (*                                                              *)
  10. (****************************************************************)
  11. unit DSort;
  12.  
  13. interface
  14.  
  15. type
  16.   ProcPtr = Pointer; { ProcPtr holds the address of a procedure }
  17.  
  18. function LTurboSort(ItemLength : integer;
  19.                    InpPtr, LessPtr, OutPtr : ProcPtr) : integer;
  20. { InpPtr, LessPtr,  and OutPtr are procedure pointers which hold the
  21.   address of the user input procedure, less function, and output procedure,
  22.   respectively.  ItemLength is the size of the item to be sorted (in bytes).
  23.   Use SizeOf(MyRec) to calculate this value. }
  24.  
  25. procedure DsortRelease(var ReleaseRecord);
  26. { Called by the user's input routine to pass a record in to be
  27.   sorted. }
  28.  
  29. procedure DsortReturn(var ReturnRecord);
  30. { Called by the user's output routine to retrieve the next
  31.   record from the sort. }
  32.  
  33. function DsortEOS : boolean;
  34. { Called by the user's output routine, DsortEOS returns true if all
  35.   of the sorted records have been returned. }
  36.  
  37. implementation
  38. {$R-}
  39. {$I-}
  40.  
  41. var
  42.   GluePtr : ProcPtr;
  43.  
  44. {$F+}
  45. procedure CallProc;
  46. inline($FF/$1E/GluePtr);  {CALL DWORD PTR GluePtr}
  47.  
  48. function Less(var x, y):boolean;
  49. inline($FF/$1E/GluePtr);  {CALL DWORD PTR GluePtr}
  50. {$F-}
  51.  
  52. Type
  53.    SortPointer = ^Byte;
  54.  
  55. Var
  56.    SortRecord : Record  { Global variables used by all routines }
  57.                    { variables concerning paging }
  58.                    N           : LongInt; { no of records to be sorted      }
  59.                    B           : LongInt; { no of records pr page           }
  60.                    Pages       : 0..10;   { No of pages in memory           }
  61.                    SecPrPage,             { no of sectors pr page           }
  62.                    NDivB,
  63.                    NModB       : LongInt; { = M Div B, N Mod B respectively }
  64.  
  65.                    Buf         : Array[0..10] Of SortPointer;
  66.                                           { Addresses of buffers            }
  67.                    Page        : Array[0..10] Of Integer;
  68.                                           { Nos of pages in workarea        }
  69.                    W           : Array[0..10] Of Boolean;
  70.                                           { dirty-bits : is page changed ?  }
  71.  
  72.                    Udix        : LongInt; { Udix points to the next record
  73.                                              to be returned }
  74.  
  75.                    F           : File;    { File used for external sorting  }
  76.  
  77.                    FileCreated : Boolean; { Is external file used           }
  78.  
  79.                    Error     : Integer; { Has an i/o error occurred       }
  80.  
  81.                    ItemLength     : Integer; { Length of record                }
  82.              End;
  83.  
  84.  
  85.  
  86.    Procedure SortPut(Addr: SortPointer; PageNo: Integer);
  87.       { Write page PageNo on file, address of page in memory is Addr }
  88.    var
  89.      BW : integer;
  90.    Begin
  91.       If SortRecord.Error=0 Then Begin  { No i/o error }
  92.          Seek(SortRecord.F, PageNo*SortRecord.SecPrPage);
  93.          BlockWrite(SortRecord.F, Addr^, SortRecord.SecPrPage, BW);
  94.          If BW = 0 Then SortRecord.Error:=10  { write error }
  95.       End
  96.    End;
  97.  
  98.  
  99.    Procedure SortFetchAddr( Ix: LongInt; Var Adr: SortPointer);
  100.       { Find address in memory for record no Ix. It is assumed
  101.         that record Ix is in memory }
  102.  
  103.       Var IxPage : Integer;
  104.           I      : 0..10;
  105.  
  106.    Begin
  107.       IxPage:= Ix Div SortRecord.B;
  108.       I:= 0;
  109.       While SortRecord.Page[i] <> IxPage Do I:=I+1;
  110.       { IxPage = SortRecord.Page [I] }
  111.       Adr:=Ptr(Seg(SortRecord.Buf[I]^),
  112.                Ofs(SortRecord.Buf[I]^) +
  113.                (Ix Mod SortRecord.B)* SortRecord.ItemLength);
  114.    End;
  115.  
  116.  
  117.    Procedure SortFetchPage( Ix, U1, U2 : LongInt);
  118.       { After call of SortFetchPage the record Ix is in memory.
  119.         If records U1 and U2 are in memory before call, then 
  120.         they are not overwritten since we soon will need them   }
  121.  
  122.       Var U1Page,
  123.           U2Page,
  124.           IxPage : Integer;
  125.           Victim : 0..10;   { The chosen page to be written to file }
  126.  
  127.       Procedure SOget(Addr: SortPointer; Pageno: Integer);
  128.          { Read page PageNo into memory at address Addr }
  129.       var
  130.         BR : integer;
  131.       Begin
  132.          If SortRecord.Error=0 Then Begin
  133.             Seek(SortRecord.F, Pageno*SortRecord.SecPrPage);
  134.             BlockRead(SortRecord.F, Addr^, SortRecord.SecPrPage, BR);
  135.             If BR = 0 Then SortRecord.Error:=11  { read error }
  136.          End;
  137.       End;
  138.  
  139.       Function InMem(Ix: LongInt): Boolean;
  140.          { InMem returns true if record ix is in memory }
  141.          Var I,IxPage : Integer;
  142.              Flag     : Boolean;
  143.       Begin
  144.          IxPage:= Ix Div SortRecord.B;
  145.          Flag:=False;
  146.          For I:=0 To SortRecord.Pages-1 Do
  147.             If Ixpage=SortRecord.Page[I] Then Flag:=True;
  148.          InMem:=Flag
  149.       End;
  150.  
  151.    Begin   { SortFetchPage }
  152.       If (Not InMem(Ix)) Then Begin
  153.          { Record Ix not in memory }
  154.          IxPage:= Ix Div SortRecord.B;
  155.          Victim:=0; 
  156.          U1Page:=U1 Div SortRecord.B;
  157.          U2Page:=U2 Div SortRecord.B;
  158.          While ((SortRecord.Page[Victim]=U1Page) Or
  159.                (SortRecord.Page[Victim]=U2Page)) Do  
  160.             Victim:=Victim+1;
  161.          { SortRecord.Page[Victim] not in U }
  162.          If SortRecord.W[Victim] Then     { Dirty bit set }
  163.             SortPut(SortRecord.Buf[Victim],SortRecord.Page[Victim]);
  164.          SoGet(SortRecord.Buf[Victim],IxPage);
  165.          SortRecord.Page[Victim]:= IxPage;
  166.          SortRecord.W[Victim]:= False;
  167.       End
  168.    End;
  169.  
  170. function LTurboSort(ItemLength : integer;
  171.                     InpPtr, LessPtr, OutPtr : ProcPtr) : integer;
  172.    { Function TurboSort returns an integer specifying the result of
  173.      the sort
  174.      LTurboSort=0  : Sorted
  175.      LTurboSort=3  : Workarea too small
  176.      LTurboSort=8  : Illegal itemlength
  177.      LTurboSort=9  : More than MaxLongInt records
  178.      LTurboSort=10 : Write error during sorting ( disk full )
  179.      LTurboSort=11 : Read error during sorting
  180.      LTurboSort=12 : Impossible to create new file ( directory full ) }
  181.  
  182.    Const
  183.       SecSize = 128;
  184.       UserStack = 2000.0;          { Minimum  memory for user        }
  185.  
  186.    Var
  187.       SaveZ,
  188.       SwopPost : SortPointer;
  189.       SafetyP,
  190.       WorkArea : Real;            { No of bytes internal memory    }
  191.       I,
  192.       PageSize : Integer;         { No of bytes pr page            }
  193.  
  194.    Function Convert(I:Integer):Real;
  195.       { Convert negative integers to positive reals }
  196.    Begin
  197.       If I<0.0 Then   { I greater than MaxInt }
  198.          Convert:=I+65536.0
  199.       Else
  200.          Convert:=I
  201.    End;
  202.  
  203.    Function SortAvail:Real;
  204.       { Redefine MaxAvail to return real result }
  205.       Var I : Real;
  206.    Begin
  207.    (*
  208.       I:=Convert(MaxAvail);
  209.       I:=16.0*I; *)
  210.  
  211.       SortAvail:= MaxAvail;
  212.    End;
  213.  
  214.  
  215.    Procedure QuickSort;
  216.       { Non-recursive version of quicksort algorithm as given
  217.         in Nicklaus Wirth : Algorithms + Data Structures = Programs }
  218.  
  219.       Procedure Exchange(I,J: LongInt);
  220.          { Change records I and J }
  221.          Var
  222.             P,R,S   : LongInt;
  223.             K,L     : 0..10;
  224.             IAddr,
  225.             JAddr   : SortPointer;
  226.    
  227.       Begin
  228.          P:= I Div SortRecord.B;
  229.          K:=0;
  230.          While SortRecord.Page[k]<>P Do K:=K+1;
  231.          P:= J Div SortRecord.B;
  232.          L:=0;
  233.          While SortRecord.Page[L]<>P Do L:=L+1;
  234.          R:= I Mod SortRecord.B; 
  235.          S:= J Mod SortRecord.B;
  236.          IAddr:= Ptr(Seg(SortRecord.Buf[K]^),
  237.                      Ofs(SortRecord.Buf[K]^) + R*ItemLength);
  238.          JAddr:= Ptr(Seg(SortRecord.Buf[L]^),
  239.                      Ofs(SortRecord.Buf[L]^) + S*ItemLength);
  240.          Move(IAddr^,SwopPost^,ItemLength);
  241.          Move(JAddr^,IAddr^,ItemLength);
  242.          Move(Swoppost^,JAddr^,ItemLength);
  243.          SortRecord.W[K]:= True;
  244.          SortRecord.W[L]:= True;
  245.       End;
  246.    
  247.       Const 
  248.          MaxStack = 32; { Log2(N) = MaxStack, i. e. for MaxStack = 32
  249.                            it is possible to sort over 2 billion records }
  250.       Var
  251.          { The stacks }
  252.          LStack : Array[1..MaxStack] Of LongInt; { Stack of left  index }
  253.          RStack : Array[1..MaxStack] Of LongInt; { Stack of right index }
  254.          Sp     : Integer;                       { Stack SortPointer        }
  255.  
  256.          M,L,R,I,J         : LongInt;
  257.          XAddr,YAddr,ZAddr : SortPointer;
  258.  
  259.    Begin
  260.       { The quicksort algorithm }
  261.       If SortRecord.N>0 Then 
  262.       Begin
  263.          LStack[1]:=0;
  264.          RStack[1]:=SortRecord.N-1;
  265.          Sp:=1
  266.       End Else Sp:=0;
  267.  
  268.       While Sp>0 do
  269.       Begin
  270.          { Pop(L,R) }
  271.          L:=LStack[Sp]; 
  272.          R:=RStack[Sp]; 
  273.          Sp:=Sp-1;
  274.          Repeat
  275.             I:=L; J:=R;
  276.             M:=(I+J) shr 1;
  277.             SortFetchPage(M,I,J);       { get M, hold I and J }
  278.             { record M in memory}
  279.             If SortRecord.Error<>0 Then Exit; { End program }
  280.             SortFetchAddr(M,ZAddr);
  281.             Move(ZAddr^,SaveZ^,ItemLength);
  282.             Repeat
  283.                SortFetchPage(I,J,M);    { get I, hold J and M }
  284.                { I and M in memory }
  285.                If SortRecord.Error<>0 Then Exit; { End program }
  286.                SortFetchAddr(I,XAddr);
  287.                While Less(XAddr^,SaveZ^) do
  288.                Begin
  289.                   I:=I+1;
  290.                   SortFetchPage(I,J,M);
  291.                   SortFetchAddr(I,XAddr);
  292.                   If SortRecord.Error<>0 Then Exit; { End program }
  293.                End;
  294.                { I and M in memory }
  295.                SortFetchPage(J,I,M);     { Get J, hold I and M }
  296.                { I, J and M in memory }
  297.                If SortRecord.Error<>0 Then Exit;  { End program }
  298.                SortFetchAddr(J,YAddr);
  299.                While Less(SaveZ^,YAddr^) do
  300.                Begin
  301.                   J:=J-1;
  302.                   SortFetchPage(J,I,M);
  303.                   SortFetchAddr(J,YAddr);
  304.                   If SortRecord.Error<>0 Then Exit;  { End program }
  305.                End;
  306.                { I, J and M in memory }
  307.                If I<=J Then
  308.                Begin
  309.                   If I<>J Then Exchange(I,J);
  310.                   I:=I+1;
  311.                   J:=J-1;
  312.                End;
  313.             Until I>J;
  314.             { Push longest interval on stack }
  315.             If J-L < R-I Then
  316.             Begin
  317.                If I<R Then
  318.                Begin
  319.                   { Push(I,R) }
  320.                   Sp:=Sp+1;
  321.                   LStack[Sp]:=I;
  322.                   RStack[Sp]:=R;
  323.                End;
  324.                R:=J
  325.             End
  326.             Else
  327.             Begin
  328.                If L<J Then
  329.                Begin
  330.                   { Push(L,J) }
  331.                   Sp:=Sp+1;
  332.                   LStack[Sp]:=L;
  333.                   RStack[Sp]:=J;
  334.                End;
  335.                L:=I
  336.             End;
  337.  
  338.           Until L>=R
  339.        End;
  340.     End  { QuickSort };
  341.  
  342.  
  343.  
  344. Begin { TurboSort }
  345.    If ItemLength>1 Then Begin
  346.       SortRecord.ItemLength := ItemLength;
  347.       WorkArea:=SortAvail-ItemLength-ItemLength-UserStack;
  348.  
  349.       { No of pages to be kept in memory }
  350.       SortRecord.Pages:=Trunc(WorkArea/(2.0*MaxInt)+1.0); 
  351.       If SortRecord.Pages<3 Then                   { Must be at least 3 }
  352.          SortRecord.Pages:=3;
  353.  
  354.       SortRecord.SecPrPage:=Trunc(WorkArea / SecSize) Div SortRecord.Pages;
  355.       If SortRecord.SecPrPage > 20 Then
  356.          SortRecord.SecPrPage:=4*(SortRecord.SecPrPage div 4);
  357.  
  358.       PageSize:=SortRecord.SecPrPage*SecSize; { May be negative or 0 }
  359.       If (PageSize=0) And (SortRecord.SecPrPage>0) Then
  360.          SafetyP:=65536.0    { = 2*MaxInt }
  361.       Else
  362.          SafetyP:=Convert(PageSize);
  363.       SortRecord.B:= Trunc(SafetyP/ItemLength);
  364.  
  365.       If SortRecord.B > 0 Then Begin { Enough memory }
  366.  
  367.          GetMem(SwopPost,ItemLength);
  368.          GetMem(SaveZ,ItemLength);
  369.          For I:=0 To SortRecord.Pages-1 Do
  370.             GetMem(SortRecord.Buf[I],PageSize);
  371.  
  372.          LTurboSort:=0;
  373.  
  374.          SortRecord.Error:=0;
  375.          SortRecord.FileCreated:=False;
  376.          SortRecord.N:=0;
  377.          SortRecord.NModB:=0;
  378.          SortRecord.NDivB:=0;
  379.          For I:=0 To SortRecord.Pages-1 Do
  380.             SortRecord.Page[I]:=I;
  381.          GluePtr := InpPtr;
  382.          CallProc;   { call user defined input procedure }
  383.          { all records are read }
  384.  
  385.          If SortRecord.Error = 0 Then Begin
  386.             { No errors while reading records }
  387.             { Initialize virtual system }
  388.             For I:=0 To SortRecord.Pages-1 Do
  389.                SortRecord.W[I]:=True;
  390.  
  391.             If SortRecord.Error=0 Then
  392.             begin
  393.               GluePtr := LessPtr;
  394.               Quicksort;
  395.             end;
  396.             { End sort, return all records }
  397.             SortRecord.Udix:=0;
  398.             If SortRecord.Error=0 Then
  399.             begin
  400.               GluePtr := OutPtr;
  401.               CallProc; { call user defined output procedure }
  402.             end;
  403.          End;
  404.  
  405.          If SortRecord.FileCreated Then 
  406.          Begin
  407.             Close(SortRecord.F);
  408.             Erase(SortRecord.F)
  409.          End;
  410.  
  411.          { Release allocated memory }
  412.          For I:=SortRecord.Pages-1 DownTo 0 Do
  413.             FreeMem(SortRecord.Buf[I],PageSize);
  414.          FreeMem(SaveZ,ItemLength);
  415.          FreeMem(SwopPost,ItemLength);
  416.  
  417.       End Else SortRecord.Error:=3; { Too little memory  }
  418.    End Else SortRecord.Error:=8;    { Illegal itemlength }
  419.    LTurboSort:=SortRecord.Error;
  420. End; { LTurboSort }
  421.  
  422.  
  423. { Procedures used by user routines }
  424.  
  425.    Procedure DsortRelease(Var ReleaseRecord);
  426.      { Accept record from user }
  427.      Var
  428.         I : integer;
  429.         BufNo : LongInt;
  430.         Point : SortPointer;
  431.    Begin
  432.       If SortRecord.Error=0 Then Begin
  433.          If SortRecord.N=MaxLongInt Then
  434.          { Only possible to sort MaxLongInt records }
  435.             SortRecord.Error:=9;
  436.          If ((SortRecord.NModB=0) and (SortRecord.NDivB >= SortRecord.Pages)) Then
  437.          Begin
  438.             { Write out last read page }
  439.             If SortRecord.NDivB=SortRecord.Pages Then Begin
  440.                { create user file }
  441.                Assign(SortRecord.F,'SOWRK.$$$');
  442.                Rewrite(SortRecord.F);
  443.                If IOResult<>0 Then SortRecord.Error:=12
  444.                Else SortRecord.FileCreated:=True;
  445.                { Fill page 0 to Pages-2 }
  446.                For I:=0 To SortRecord.Pages-2 Do
  447.                   SortPut(Ptr(DSeg,0), I);
  448.             End;
  449.             { Write user record in last page }
  450.             SortPut(SortRecord.Buf[SortRecord.Pages-1],
  451.                     SortRecord.Page[SortRecord.Pages-1]);
  452.             SortRecord.Page[SortRecord.Pages-1]:=
  453.                 SortRecord.Page[SortRecord.Pages-1]+1;
  454.          End;
  455.  
  456.          If SortRecord.NDivB>=SortRecord.Pages Then
  457.             BufNo:=SortRecord.Pages-1
  458.          Else
  459.             BufNo:=SortRecord.NDivB;
  460.          Point:= Ptr(Seg(SortRecord.Buf[BufNo]^),
  461.                      Ofs(SortRecord.Buf[BufNo]^) +
  462.                      SortRecord.NModB*SortRecord.ItemLength);
  463.          Move(ReleaseRecord,Point^,SortRecord.ItemLength);
  464.  
  465.          SortRecord.N:= SortRecord.N+1;
  466.          SortRecord.NModB:=SortRecord.NModB + 1;
  467.          If SortRecord.NModB=SortRecord.B Then Begin
  468.             SortRecord.NModB:=0;
  469.             SortRecord.NDivB:=SortRecord.NDivB+1
  470.          End;
  471.       End;
  472.    End   { DsortRelease };
  473.  
  474.  
  475.    Procedure DsortReturn(Var ReturnRecord);
  476.       { Return record to user }
  477.       Var AuxAddr : SortPointer;
  478.    Begin
  479.       If SortRecord.Error=0 Then Begin
  480.          SortFetchPage(SortRecord.Udix,SortRecord.N-1,-SortRecord.B);
  481.          SortFetchAddr(SortRecord.Udix,AuxAddr);
  482.          Move(AuxAddr^,ReturnRecord,SortRecord.ItemLength);
  483.          SortRecord.Udix:= SortRecord.Udix+1
  484.       End
  485.    End   { DsortReturn };
  486.  
  487.  
  488.    Function DsortEOS:Boolean;
  489.       { Returns True if all records are returned }
  490.    Begin
  491.       DsortEOS:= (SortRecord.Udix >= SortRecord.N) Or (SortRecord.Error<>0);
  492.    End;
  493.  
  494. end.
  495.  
  496.